;; Copyright (c) 2012 Alan Watson. All rights reserved. BSD-style
;; license: http://synthcode.com/license.txt

;; This library provides an interface to the system clock.

(define-library (clock system)
  
  (export type
          call-with-current-clock-values)
  
  ;; It exports two symbols: type and call-with-current-clock-values.
  ;;
  ;; type
  ;;
  ;; The value of the type variable is a symbol that describes the
  ;; system clock's behavior. It is one of: tai-like, posix-like, or
  ;; ntp-like.
  ;;
  ;; Each clock is notionally associated with two values: the current
  ;; second and the current leap second indicator.
  ;;
  ;; If the clock type is tai-like, the current second increases by one
  ;; for each TAI second and the current leap second indicator is always
  ;; false. The epoch of the current second value is 1970-01-01 00:00:00
  ;; TAI. When a leap second is observed, the following behavior is
  ;; observed:
  ;;
  ;;   UTC Time    current-second  current-leap-second-indicator
  ;;
  ;;   23:59:58.0  n               #f
  ;;   23:59:59.0  n + 1           #f
  ;;   23:59:60.0  n + 2           #f
  ;;   00:00:00.0  n + 3           #f
  ;;   00:00:01.0  n + 4           #f
  ;;
  ;; If the clock type is posix-like, the current second increases by
  ;; one for each TAI second except at the end of an inserted leap
  ;; second, when it jumps back by one second. The current leap second
  ;; indicator is always false. The epoch of the current second value is
  ;; 1970-01-01 00:00:00 UTC. Thus, an inserted leap second and the
  ;; first second of the following day are indistinguishable. When a
  ;; leap second is inserted, the following behaviour is observed:
  ;;
  ;;   UTC Time    current-second  current-leap-second-indicator
  ;;
  ;;   23:58:58.0  n               #f
  ;;   23:59:59.0  n + 1           #f
  ;;   23:59:60.0  n + 2           #f
  ;;   00:00:00.0  n + 2           #f
  ;;   00:00:00.0  n + 3           #f
  ;;
  ;; If the clock type is ntp-like, the current second increases by one
  ;; for each TAI second except at the start of an inserted leap second,
  ;; when it jumps back by one second. The current leap second indicator
  ;; is true during a leap second and false otherwise. The epoch of the
  ;; current second value is 1970-01-01 00:00:00 UTC. Thus, when a leap
  ;; second is inserted, the following behaviour is observed:
  ;;
  ;;   UTC Time    current-second  current-leap-second-indicator
  ;;
  ;;   23:58:58.0  n               #f
  ;;   23:59:59.0  n + 1           #f
  ;;   23:59:60.0  n + 1           #t
  ;;   00:00:00.0  n + 2           #f
  ;;   00:00:00.0  n + 3           #f
  ;;
  ;; (call-with-current-clock-values p)
  ;;
  ;; The call-with-current-clock-values procedure performs a tail call
  ;; to the procedure p with two arguments, the system clock's current
  ;; seconds and the current leap second indicator. The argument p must
  ;; be a procedure taking two arguments.
  
  (import (scheme base))
  
  (cond-expand
   
   (chibi
    
    (import (scheme process-context))
    
    ;; The shared library defines two bindings: current-clock-second and
    ;; current-ntp-clock-values.
    ;;
    ;; The (current-clock-second) procedure returns the number of
    ;; seconds since the epoch according to POSIX gettimeofday()
    ;; function.
    ;;
    ;; The value of current-ntp-clock-values is either #f or a
    ;; procedure. If it is a procedure, then (current-ntp-clock-values)
    ;; returns a pair containing values obtained from the ntp_gettime()
    ;; function: the car is the number of seconds since the epoch and
    ;; the cdr is #t during a leap second and #f otherwise.
    
    (include-shared "system")
    
    (begin
      
      ;; If the environment variable SEXP_CLOCK_TYPE is set, its value
      ;; is used for the system clock type. If the environment variable
      ;; SEXP_CLOCK_TYPE is not set, then the system clock is ntp-like
      ;; if current-ntp-clock-values is a procedure and is posix-like
      ;; otherwise.
      
      (define type
        (string->symbol
         (or (get-environment-variable "SEXP_CLOCK_TYPE")
             (if current-ntp-clock-values "ntp-like" "posix-like"))))
      
      (case type
        ((posix-like tai-like))
        ((ntp-like)
         (unless (procedure? current-ntp-clock-values)
           (error "no ntp-like system clock is available.")))
        (else
         (error "invalid system clock type" type)))
      
      
      ;; The value of the environment variable SEXP_CLOCK_EPOCH_OFFSET
      ;; specifies the offset of the system clock relative to the
      ;; standard epoch (1970-01-01 00:00:00 UTC for posix-like and
      ;; ntp-like clocks and 1970-01-01 00:00:00 TAI for tai-like system
      ;; clocks). If it not set, the offset is assumed to be zero. In
      ;; call-with-current-clock-values, the offset is added to the
      ;; current seconds before calling the procedure argument.
      
      (define epoch-offset
        (inexact
         (string->number
          (or (get-environment-variable "SEXP_CLOCK_EPOCH_OFFSET")
              "0"))))
      
      ;; Normally, one does not need to specify either the clock type or
      ;; clock epoch explicitly. One case where it might be necessary is
      ;; if the system clock runs on the TAI-10 timescale. In this case,
      ;; one should set SEXP_CLOCK_TYPE to "tai-like" and
      ;; SEXP_CLOCK_EPOCH_OFFSET to -10.
      
      ;; The call-with-current-clock-values obtains the clock values
      ;; from the current-ntp-clock-values procedure, if the system
      ;; clock is ntp-like, and from the current-clock-second procedure
      ;; otherwise.
      
      (define call-with-current-clock-values
        (case type
          ((ntp-like)
           (if (zero? epoch-offset)
             (lambda (p)
               (let ((values-pair (current-ntp-clock-values)))
                 (p (car values-pair) (cdr values-pair))))
             (lambda (p)
               (let ((values-pair (current-ntp-clock-values)))
                 (p (+ (car values-pair) epoch-offset) (cdr values-pair))))))
          (else
           (if (zero? epoch-offset)
             (lambda (p)
               (p (current-clock-second) #f))
             (lambda (p)
               (p (+ (current-clock-second) epoch-offset) #f))))))))))
